home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / toplevel.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  6KB  |  239 lines
  1. /* ******************************************************************** */
  2. /* toplevel.c        Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* toplevel syntactic forms and special forms                           */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, March 1990 (Compiler rationalisation)
  10.  *     Largely just modulised variants of the originals.
  11.  *   Version 2, August 1990
  12.  *     Added 'define' (kjp)
  13.  */
  14.  
  15. #include "funcalls.h"
  16. #include "defs.h"
  17. #include "structs.h"
  18.  
  19. #include "error.h"
  20. #include "global.h"
  21.  
  22. #include "symboot.h"
  23. #include "allocate.h"
  24. #include "modules.h"
  25. #include "specials.h"
  26. #include "toplevel.h"
  27.  
  28. /* Language provided toplevel forms */
  29.  
  30. /*
  31.  * Start with the most fundamental...
  32.  *   The first argument to ALL special forms is now the module it is
  33.  *   called within - not all need it but...
  34.  */
  35.  
  36. /* Top level defining forms */
  37.  
  38. LispObject TL_define(LispObject *stacktop,LispObject mod,LispObject forms)
  39. {
  40.   LispObject bind_spec,name,type;
  41.   LispObject ret;
  42.  
  43.   if (!is_cons(forms))
  44.     CallError(stacktop,"define: no binding spec",forms,NONCONTINUABLE);
  45.  
  46.   bind_spec = CAR(forms); 
  47.  
  48.   if (is_symbol(bind_spec)) {
  49.     ret = TL_deflex(stacktop,mod,forms);
  50.     return(ret);
  51.   }
  52.  
  53.   if (!is_cons(bind_spec))
  54.     CallError(stacktop,"define: invalid binding spec",forms,NONCONTINUABLE);
  55.   
  56.   type = CAR(bind_spec); bind_spec = CDR(bind_spec);
  57.  
  58.   if (!is_cons(bind_spec))
  59.     CallError(stacktop,"define: invalid binding spec",forms,NONCONTINUABLE);
  60.  
  61.   name = CAR(bind_spec); bind_spec = CDR(bind_spec);
  62.  
  63.   if (type == sym_function) {
  64.     LispObject xx;
  65.     STACK_TMP(mod);
  66.     EUCALLSET_2(xx, Fn_cons, name, CDR(forms));
  67.     UNSTACK_TMP(mod);
  68.     ret = TL_defun(stacktop,mod,xx);
  69.     return(ret);
  70.   }
  71.  
  72.   if (type == sym_macro) {
  73.     LispObject xx;
  74.     STACK_TMP(mod);
  75.     EUCALLSET_2(xx, Fn_cons, name, CDR(forms));
  76.     UNSTACK_TMP(mod);
  77.     ret = TL_defmacro(stacktop,mod,xx);
  78.     return(ret);
  79.   }
  80.  
  81.   if (type == sym_constant) {
  82.     LispObject xx;
  83.     STACK_TMP(mod);
  84.     EUCALLSET_2(xx, Fn_cons, name, CDR(forms));
  85.     UNSTACK_TMP(mod);
  86.     ret = TL_defconstant(stacktop,mod,xx);
  87.     return(ret);
  88.   }
  89.  
  90.   CallError(stacktop,"define: unknown binding type",forms,NONCONTINUABLE);
  91.  
  92.   return(nil);
  93. }
  94.  
  95. LispObject TL_defun(LispObject *stacktop,LispObject mod,LispObject forms)
  96. {
  97.   LispObject name,fun;
  98.  
  99.   if (forms == nil)
  100.     CallError(stacktop,"defun form: no function name",nil,NONCONTINUABLE);
  101.  
  102.   name = CAR(forms); forms = CDR(forms);
  103.  
  104.   if (!is_symbol(name))
  105.     CallError(stacktop,
  106.           "defun form: non-symbolic function name",name,NONCONTINUABLE);
  107.  
  108.   /* Use name for bind and redirect to lambda!! */
  109.  
  110.   /* What we do here's questionable... */
  111.  
  112.   STACK_TMP(mod);
  113.   STACK_TMP(name);
  114.   EUCALLSET_3(fun,Sf_lambda,mod,NULL,forms);
  115.   UNSTACK_TMP(name);
  116.   UNSTACK_TMP(mod);
  117.   fun->I_FUNCTION.name = name;
  118.  
  119.   STACK_TMP(name);
  120.   (void) module_set_new_constant(stacktop,mod,name,fun);
  121.   UNSTACK_TMP(name);
  122.  
  123.   return(name);
  124. }
  125.  
  126. LispObject TL_defmacro(LispObject *stacktop,LispObject mod,LispObject forms)
  127. {
  128.   LispObject name, mac;
  129.  
  130.   if (forms == nil)
  131.     CallError(stacktop,"defmacro form: no macro name",nil,NONCONTINUABLE);
  132.  
  133.   name = CAR(forms); forms = CDR(forms);
  134.  
  135.   if (!is_symbol(name))
  136.     CallError(stacktop,
  137.           "defmacro form: non-symbolic macro name",name,NONCONTINUABLE);
  138.  
  139.   /* Use name for bind and redirect to lambda!! */
  140.  
  141.   /* What we do here's questionable... */
  142.   STACK_TMP(mod);
  143.   STACK_TMP(name);
  144.   EUCALLSET_3(mac,Sf_mlambda,mod,NULL,forms);
  145.   UNSTACK_TMP(name);
  146.   UNSTACK_TMP(mod);
  147.   STACK_TMP(name);
  148.   (void) module_set_new_constant(stacktop,mod,name,mac);
  149.   UNSTACK_TMP(name);
  150.   
  151.   return(name);
  152. }
  153.  
  154. LispObject TL_deflex(LispObject *stacktop,LispObject mod,LispObject forms)
  155. {
  156.   LispObject name,val;
  157.  
  158.   if (!is_cons(forms))
  159.     CallError(stacktop,"deflocal form: no binding name",nil,NONCONTINUABLE);
  160.  
  161.   name = CAR(forms); forms = CDR(forms);
  162.  
  163.   if (!is_symbol(name))
  164.     CallError(stacktop,"deflocal form: non-symbolic binding name",
  165.           name,NONCONTINUABLE);
  166.  
  167.   /* What we do here's questionable too... */
  168.   STACK_TMP(mod);
  169.   STACK_TMP(name);
  170.   EUCALLSET_3(val,module_eval,mod,NULL,CAR(forms));
  171.   UNSTACK_TMP(name);
  172.   UNSTACK_TMP(mod);
  173.   STACK_TMP(name);
  174.   (void) module_set_new(stacktop,mod,name,val);
  175.   UNSTACK_TMP(name);
  176.  
  177.   return(name);
  178. }
  179.  
  180. LispObject TL_defconstant(LispObject *stacktop,LispObject mod,LispObject forms)
  181. {
  182.   LispObject name,val;
  183.  
  184.   if (!is_cons(forms))
  185.     CallError(stacktop,"defconstant form: no binding name",nil,NONCONTINUABLE);
  186.  
  187.   name = CAR(forms); forms = CDR(forms);
  188.  
  189.   if (!is_symbol(name))
  190.     CallError(stacktop,"defconstant form: non-symbolic binding name",
  191.           name,NONCONTINUABLE);
  192.  
  193.   /* What we do here's questionable too... */
  194.   
  195.   STACK_TMP(mod);
  196.   STACK_TMP(name);
  197.   EUCALLSET_3(val,module_eval,mod,NULL,CAR(forms));
  198.   UNSTACK_TMP(name);
  199.   UNSTACK_TMP(mod);
  200.   STACK_TMP(name);
  201.   (void) module_set_new_constant(stacktop,mod,name,val);
  202.   UNSTACK_TMP(name);
  203.  
  204.   return(name);
  205. }
  206.  
  207. LispObject TL_defvar(LispObject *stacktop,LispObject mod,LispObject forms)
  208. {
  209.   LispObject id;
  210.  
  211.   if (!is_cons(forms))
  212.     CallError(stacktop,"defvar: illegal empty defvar form",nil,NONCONTINUABLE);
  213.  
  214.   id = CAR(forms); forms = CDR(forms);
  215.  
  216.   if (CDR(forms) != nil)
  217.     CallError(stacktop,"defvar: additional defvar forms",nil,NONCONTINUABLE);
  218.  
  219.   if (!is_symbol(id))
  220.     CallError(stacktop,"defvar: non-symbolic id",id,NONCONTINUABLE);
  221.  
  222.   if (reserved_symbol_p(id))
  223.     CallError(stacktop,"defvar: reserved id",id,NONCONTINUABLE);
  224.  
  225.   STACK_TMP(id);
  226.   EUCALLSET_3(forms,module_eval,mod,NULL,CAR(forms));
  227.   UNSTACK_TMP(id);
  228.   STACK_TMP(forms);
  229.   if ((id->SYMBOL).gvalue !=NULL) {
  230.     fprintf(stderr,"Illegal re-declaration of '");
  231.     STACK_TMP(id);
  232.     EUCALL_2(Fn_prin,id,StdErr);
  233.     UNSTACK_TMP(id);
  234.     fprintf(stderr,"' by defvar\n");
  235.   }
  236.   UNSTACK_TMP(forms);
  237.   return((id->SYMBOL).gvalue = forms);
  238. }
  239.